perm filename BEAMX.F4[NEW,LCS] blob sn#493266 filedate 1980-01-12 generic text, type T, neo UTF8
	SUBROUTINE BEAMX
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RRJJ/RJJ2,RJJ(20)
	1 /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
	EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3)),
	1 (R6,RJQ(4)),(J10,JQ(8)),(J6,JQ(4)),(R4,RJQ(2)),(R7,RJQ(5))
	1,(R3,RJQ(1)),(J8,JQ(6)),(J7,JQ(5))
	1,(R11,RJQ(9)),(R10,RJQ(8)),(R8,RJQ(6)),(RJ3,RJJ(1))
	1,(R9,RJQ(7)),(J9,JQ(7))

	IF(J10.GE.100)GO TO 6
	CALL BMSTF
	RETURN
6	JZ=-2
	JX8=R8
	IF(JX8.GE.-1)GO TO 16
	JX8=R8/10.0
	JX8=JX8*10
C MAKE SURE LAST DIGIT IS ZERO
	R8=JX8
16	RR8=R8
	R8=0
	RR9=R9
	R9=0
	RR6=R6
	RR3=R3
	RR4=R4
	RR5=R5
	RSTJ=RSTJ2
	J=10*(J7/10)
C J=STEM DIR. (10 OR 20)
	JJ=J10/100
	JJ10=J10-JJ*100
C IF 3RD DIGIT OF P10 = 0, THEN TWO SECONDARY BEAM GROUPS ARE MADE.
C  THEN P8 AND P9 ARE THE LIMITS OF THE GAP BETWEEN THE SECONDARY GROUPS.

C IF 3RD DIGIT OF P10 = 1, THEN SINGLE SECONDARY BEAM GROUP IS MADE.
C  THEN P8 AND P9 ARE THE OUTER LIMITS OF THE SECONDARY GROUP
	JJ7=J7-J
C   J7=NUM. OF FULL BEAMS   (1ST DIGIT OF P10=NUM OF ADDED BEAMS)
7	J10=0
5	J8=R8
	J9=R9
	R7=J7
	R10=J10
	CALL BMSTF
	JZ=JZ+1
	IF(JZ)1,2,3          
3	RETURN

1	IF(RR8.GE.0)GO TO 8
	IF(JX8.GE.-20)GO TO 11
C UNATTACHED PARTIAL BEAM: 
C  P8= -10=ON LEFT, -20=RIGHT, -30=BOTH
	RR8=RR8+10
	IF(JX8.EQ.-31)GO TO 11
	JX8=JX8-1
	RR9=0
C ↑↑↑ A PRECAUTION
	JZ=JZ-2
11	R8=RR8-AMOD(R7,10.0)
10	R9=RR9
	JZ=JZ+1
	GO TO 4
8	IF(JJ10.EQ.0)GO TO 9
C NEXT MAKES ONE SECONDARY BEAM GROUP.
	R8=RR8
	GO TO 10
9	R8=-1
	R9=RR8
4	J7=J+JJ
	R6=RR6
	R3=RR3
	J3=RR3
	R4=RR4
	R5=RR5
	J10=JJ7
C J10 IS DISPLACEMENT FOR OTHER BEAMS
	RSTJ2=RSTJ
	GO TO 5
2	R8=RR9
	R9=-1
	GO TO 4
	END